home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / demos / moire.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-22  |  3.5 KB  |  123 lines
  1. Program Moire;
  2.  
  3. {
  4.       Will now open a default screen (can be any size) with
  5.       the new look. The window get it's size depending on
  6.       the screen size.
  7.       14 May 1998
  8.  
  9.       Translated to FPC from PCQ Pascal.
  10.       15 Aug 1998.
  11.       nils.sjoholm@mailbox.swipnet.se
  12. }
  13.  
  14. uses Exec, Intuition, Graphics, Utility;
  15.  
  16. {$I tagutils.inc}
  17.  
  18. const
  19.     pens : array [0..0] of Integer = ( not 0);
  20.     ltrue = 1;
  21.  
  22. var
  23.     w  : pWindow;
  24.     s  : pScreen;
  25.     m  : pMessage;
  26.     thetags : array[0..17] of tTagItem;
  27.  
  28.  
  29. Procedure DoDrawing(RP : pRastPort);
  30. var
  31.     x  : word;
  32.     Pen : Byte;
  33.     Stop : word;
  34. begin
  35.     Pen := 1;
  36.     while true do begin
  37.     with w^ do begin
  38.         x := 0;
  39.         while x < Pred(Width - BorderRight - BorderLeft) do begin
  40.         Stop := Pred(Width - BorderRight);
  41.         SetAPen(RP, Pen);
  42.         Move(RP, Succ(x + BorderLeft), BorderTop);
  43.         Draw(RP, Stop - x, Pred(Height - BorderBottom));
  44.         Pen := (Pen + 1) mod 4;
  45.         Inc(x);
  46.         end;
  47.         m := GetMsg(UserPort);
  48.         if m <> Nil then
  49.         Exit;
  50.         x := 0;
  51.         while x < Pred(Height - BorderBottom - BorderTop) do begin
  52.         Stop := Pred(Height - BorderBottom);
  53.         SetAPen(RP, Pen);
  54.         Move(RP, Pred(Width - BorderRight), Succ(x + BorderTop));
  55.         Draw(RP, Succ(BorderLeft), Stop - x);
  56.         Pen := (Pen + 1) mod 4;
  57.         Inc(x);
  58.         end;
  59.         m := GetMsg(UserPort);
  60.         if m <> Nil then
  61.         Exit;
  62.     end;
  63.     end;
  64. end;
  65.  
  66. begin
  67.     { Note that the startup code of all FPC programs depends on
  68.       Intuition, so if we got to this point Intuition must be
  69.       open, so the run time library just uses the pointer that
  70.       the startup code created.  Same with DOS, although we don't
  71.       use that here. }
  72.  
  73.     GfxBase := OpenLibrary(GRAPHICSNAME,0);
  74.     if GfxBase <> nil then begin
  75.  
  76.     thetags[0] := TagItem(SA_Pens,      longint(@pens));
  77.     thetags[1] := TagItem(SA_Depth,     2);
  78.     thetags[2] := TagItem(SA_DisplayID, HIRES_KEY);
  79.     thetags[3] := TagItem(SA_Title,     Long(PChar('Close the Window to End This Demonstration'#0)));
  80.     thetags[4].ti_Tag := TAG_END;
  81.  
  82.     s := OpenScreenTagList(NIL, @thetags);
  83.     if s <> NIL then begin
  84.  
  85.     thetags[0] := TagItem(WA_IDCMP,        IDCMP_CLOSEWINDOW);
  86.     thetags[1] := TagItem(WA_Left,         20);
  87.     thetags[2] := TagItem(WA_Top,          50);
  88.     thetags[3] := TagItem(WA_Width,        336);
  89.     thetags[4] := TagItem(WA_Height,       100);
  90.     thetags[5] := TagItem(WA_MinWidth,     50);
  91.     thetags[6] := TagItem(WA_MinHeight,    20);
  92.     thetags[7] := TagItem(WA_MaxWidth,     -1);
  93.     thetags[8] := TagItem(WA_MaxHeight,    -1);
  94.     thetags[9] := TagItem(WA_DepthGadget,  ltrue);
  95.     thetags[10] := TagItem(WA_DragBar,      -1);
  96.     thetags[11] := TagItem(WA_CloseGadget,  -1);
  97.     thetags[12] := TagItem(WA_SizeGadget,   -1);
  98.     thetags[13] := TagItem(WA_SmartRefresh, -1);
  99.     thetags[14] := TagItem(WA_Activate,     -1);
  100.     thetags[15] := TagItem(WA_Title,        Long(PChar('Feel Free to Re-Size the Window'#0)));
  101.     thetags[16] := TagItem(WA_CustomScreen, Long(s));
  102.     thetags[17].ti_Tag := TAG_END;
  103.  
  104.     w := OpenWindowTagList(NIL, @thetags);
  105.     IF w <> NIL THEN begin
  106.  
  107.         DoDrawing(w^.RPort);
  108.         Forbid;
  109.         repeat
  110.             m := GetMsg(w^.UserPort);
  111.         until m = nil;
  112.         CloseWindow(w);
  113.         Permit;
  114.         end else
  115.         writeln('Could not open the window');
  116.         CloseScreen(s);
  117.     end else
  118.         writeln('Could not open the screen.');
  119.     CloseLibrary(GfxBase);
  120.     end else writeln('no graphics.library');
  121. end.
  122.  
  123.